home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / lang / PPCsmalltalk.lha / PPCSmallTalk / sources / primitive.c < prev    next >
C/C++ Source or Header  |  1986-10-19  |  34KB  |  1,387 lines
  1. /* 
  2.     Little Smalltalk
  3.  
  4.     Primitive manager
  5.     timothy a. budd
  6.     10/84
  7.  
  8.         hashcode code written by Robert McConeghy
  9.             (who also wrote classes Dictionary, et al).
  10. */
  11. /*
  12.     The source code for the Little Smalltalk System may be freely
  13.     copied provided that the source of all files is acknowledged
  14.     and that this condition is copied with each file.
  15.  
  16.     The Little Smalltalk System is distributed without responsibility
  17.     for the performance of the program and without any guarantee of
  18.     maintenance.
  19.  
  20.     All questions concerning Little Smalltalk should be addressed to:
  21.  
  22.         Professor Tim Budd
  23.         Department of Computer Science
  24.         The University of Arizona
  25.         Tucson, Arizona
  26.         85721
  27.         USA
  28. */
  29.  
  30. # include "object.h"
  31.  
  32. # ifdef CURSES
  33. # include <curses.h>
  34. # endif
  35.  
  36. # include <stdio.h>
  37. # include <ctype.h>
  38. # include <math.h>
  39. # include <errno.h>
  40. # include "drive.h"
  41. # include "interp.h"
  42. # include "process.h"
  43. # include "block.h"
  44. # include "string.h"
  45. # include "symbol.h"
  46. # include "number.h"
  47. # include "file.h"
  48. # include "byte.h"
  49. # include "primitive.h"
  50.  
  51. extern int errno;
  52. extern int prntcmd;
  53. extern double modf();
  54. extern long time();
  55. extern char *ctime();
  56. extern object *lookup_class();
  57. extern process *runningProcess;
  58. extern int responds_to(), generality();
  59. extern class  *mk_class();
  60. extern object *o_object, *o_true, *o_false, *o_nil, *o_number, *o_magnitude;
  61.  
  62. object *primitive(primnumber, numargs, args)
  63. int primnumber, numargs;
  64. object **args;
  65. {    object *resultobj;
  66.     object *leftarg, *rightarg, *fnd_class(), *fnd_super();
  67.     int    leftint, rightint, i, j;
  68.     double leftfloat, rightfloat;
  69.     long   clock;
  70.     char   *leftp, *rightp, *errp;
  71.     class  *aClass;
  72.     bytearray *byarray;
  73.     struct file_struct *phil;
  74.     int    opnumber = primnumber % 10;
  75.     char   strbuffer[300], tempname[100];
  76.  
  77.     errno = 0;
  78.     /* first do argument type checking */
  79.     switch(i = (primnumber / 10)) {
  80.         case 0: /* misc operations */
  81.             if (opnumber <= 5 && numargs != 1) goto argcerror;
  82.             leftarg = args[0];
  83.             break;
  84.  
  85.         case 1: /* integer operations */
  86.         case 2: 
  87.             if (numargs != 2) goto argcerror;
  88.             rightarg = args[1];
  89.             if (! is_integer(rightarg)) goto argterror;
  90.             rightint = int_value(rightarg);
  91.         case 3: 
  92.             if (i == 3 && opnumber && numargs != 1) 
  93.                 goto argcerror;
  94.             leftarg = args[0];
  95.             if (! is_integer(leftarg)) goto argterror;
  96.             leftint = int_value(leftarg);
  97.             break;
  98.  
  99.         case 4: /* character operations */
  100.             if (numargs != 2) goto argcerror;
  101.             rightarg = args[1];
  102.             if (! is_character(rightarg)) goto argterror;
  103.             rightint = int_value(rightarg);
  104.         case 5: 
  105.             if (i == 5 && numargs != 1) goto argcerror;
  106.             leftarg = args[0];
  107.             if (! is_character(leftarg)) goto argterror;
  108.             leftint = int_value(leftarg);
  109.             break;
  110.  
  111.         case 6: /* floating point operations */
  112.             if (numargs != 2) goto argcerror;
  113.             rightarg = args[1];
  114.             if (! is_float(rightarg)) goto argterror;
  115.             rightfloat = float_value(rightarg);
  116.         case 7: 
  117.             if (i == 7 && numargs != 1) goto argcerror;
  118.         case 8:
  119.             if (i == 8 && opnumber < 8 && numargs != 1) 
  120.                 goto argcerror;
  121.             leftarg = args[0];
  122.             if (! is_float(leftarg)) goto argterror;
  123.             leftfloat = float_value(leftarg);
  124.             break;
  125.  
  126.         case 9: /* symbol operations */
  127.             leftarg = args[0];
  128.             if (! is_symbol(leftarg)) goto argterror;
  129.             leftp = symbol_value(leftarg);
  130.             break;
  131.  
  132.         case 10: /* string operations */
  133.             if (numargs < 1) goto argcerror;
  134.             leftarg = args[0];
  135.             if (! is_string(leftarg)) goto argterror;
  136.             leftp = string_value(leftarg);
  137.             if (opnumber && opnumber <= 3) {
  138.                 if (numargs != 2) goto argcerror;
  139.                 rightarg = args[1];
  140.                 if (! is_string(rightarg)) goto argterror;
  141.                 rightp = string_value(rightarg);
  142.                 }
  143.             else if ((opnumber >= 4) && (opnumber <= 6)) {
  144.                 if (numargs < 2) goto argcerror;
  145.                 if (! is_integer(args[1])) goto argterror;
  146.                 i = int_value(args[1])-1;
  147.                 if ((i < 0) || (i >= strlen(leftp)))
  148.                     goto indexerror;
  149.                 }
  150.             else if ((opnumber >= 7) && (numargs != 1))
  151.                 goto argcerror;
  152.             break;
  153.  
  154.         case 11: /* misc operations */
  155.             if ((opnumber == 1) || (opnumber == 2)) {
  156.                 if (is_bltin(args[0])) goto argterror;
  157.                 if (numargs < 2) goto argcerror;
  158.                 if (! is_integer(args[1])) goto argterror;
  159.                 i = int_value(args[1]);
  160.                 if (i < 1 || i > args[0]->size)
  161.                     goto indexerror;
  162.                 }
  163.             else if ((opnumber >= 4) && (opnumber <= 6)) {
  164.                 if (numargs != 1) goto argcerror;
  165.                 if (! is_integer(args[0])) goto argterror;
  166.                 i = int_value(args[0]);
  167.                 if (i < 0) goto indexerror;
  168.                 }
  169.             else if (opnumber >= 7) {
  170.                 if (numargs < 1) goto argcerror;
  171.                 if (! is_bytearray(args[0])) goto argterror;
  172.                 byarray = (bytearray *) args[0];
  173.                 if (opnumber >= 8) {
  174.                     if (numargs < 2) goto argcerror;
  175.                     if (! is_integer(args[1]))
  176.                         goto argterror;
  177.                     i = int_value(args[1]) - 1;
  178.                     if (i < 0 || i >= byarray->a_bsize)
  179.                         goto indexerror;
  180.                     }
  181.                 }
  182.             break;
  183.  
  184.         case 12: /* string i/o operations */
  185.             if (opnumber < 6) {
  186.                 if (numargs < 1) goto argcerror;
  187.                 leftarg = args[0];
  188.                 if (! is_string(leftarg)) goto argterror;
  189.                 leftp = string_value(leftarg);
  190.                 }
  191.             break;
  192.  
  193.         case 13: /* operations on file */
  194.             if (numargs < 1) goto argcerror;
  195.             if (! is_file(args[0])) goto argterror;
  196.             phil = (struct file_struct *) args[0];
  197.             if (opnumber && (phil->fp == (FILE *) NULL)) {
  198.                 errp = "file must be open for operation";
  199.                 goto return_error;
  200.                 }
  201.             break;
  202.  
  203.         case 15: /* operations on classes */
  204.             if (opnumber < 3 && numargs != 1) goto argcerror;
  205.             if (! is_class(args[0])) goto argterror;
  206.             aClass = (class *) args[0];
  207.             break;
  208.  
  209. # ifdef PLOT3
  210.         case 17: /* plot(3) interface */
  211.             if (opnumber && opnumber <= 3) {
  212.                 if (numargs != 2) goto argcerror;
  213.                 if ((! is_integer(args[0])) || 
  214.                     (! is_integer(args[1])))
  215.                     goto argterror;
  216.                 leftint = int_value(args[0]);
  217.                 rightint = int_value(args[1]);
  218.                 }
  219.             else if ((opnumber == 6) || (opnumber == 7)) {
  220.                 if (numargs != 4) goto argcerror;
  221.                 for (i = 0; i < 4; i++)
  222.                     if (! is_integer(args[i]))
  223.                         goto argterror;
  224.                 leftint = int_value(args[0]);
  225.                 rightint = int_value(args[1]);
  226.                 i = int_value(args[2]);
  227.                 j = int_value(args[3]);
  228.                 }
  229.             else if (opnumber >= 8) {
  230.                 if (numargs != 1) goto argcerror;
  231.                 if (! is_string(args[0])) goto argterror;
  232.                 leftp = string_value(args[0]);
  233.                 }
  234.             break;
  235. # endif
  236.         }
  237.  
  238.  
  239.     /* now do operation */
  240.     switch(primnumber) {
  241.  
  242.         case 1:        /* class of object */
  243.             resultobj = fnd_class(args[0]);
  244.             if (resultobj) goto return_obj;
  245.             else goto return_nil;
  246.  
  247.         case 2:        /* get super_object */
  248.             resultobj = fnd_super(args[0]);
  249.             if (resultobj) goto return_obj;
  250.             else goto return_nil;
  251.  
  252.         case 3:        /* see if class responds to new */
  253.             leftint = 0;
  254.             if (! is_class(args[0])) goto return_boolean;
  255.             leftint = responds_to("new", (class *) args[0]);
  256.             goto return_boolean;
  257.  
  258.         case 4:        /* compute size of object */
  259.             leftint = args[0]->size;
  260.             goto return_integer;
  261.  
  262.         case 5:        /* return hashnum of object */
  263.             if (is_integer(leftarg))
  264.                 leftint = int_value(leftarg);
  265.             else if (is_character(leftarg))
  266.                 leftint = int_value(leftarg);
  267.             else if (is_symbol(leftarg))
  268.                 leftint = (int) symbol_value(leftarg);
  269.             else if (is_string(leftarg)) {
  270.                 leftp = string_value(leftarg);
  271.                 leftint = 0;
  272.                 for(i = 0; *leftp != 0; leftp++){
  273.                     leftint += *leftp;
  274.                     i++;
  275.                     if(i > 5)
  276.                        break;
  277.                     }
  278.                 }
  279.             else /* for all other objects return address */
  280.                 leftint = (int) &leftarg;
  281.             if (leftint < 0)
  282.                 leftint = -leftint;
  283.             goto return_integer;
  284.  
  285.         case 6:        /* built in object type testing */
  286.             if (numargs != 2) goto argcerror;
  287.             leftint = (args[0]->size == args[1]->size);
  288.             goto return_boolean;
  289.  
  290.         case 7:        /* object equality testing */
  291.             if (numargs != 2) goto argcerror;
  292.             leftint = (args[0] == args[1]);
  293.             goto return_boolean;
  294.  
  295.         case 8:        /* toggle debugging flag */
  296.             if (numargs == 0) {
  297.                 debug = 1 - debug;
  298.                 goto return_nil;
  299.                 }
  300.             if (numargs != 2) goto argcerror;
  301.             if (! is_integer(args[0])) goto argterror;
  302.             if (! is_integer(args[1])) goto argterror;
  303.             leftint = int_value(args[0]);
  304.             rightint = int_value(args[1]);
  305.             switch(leftint) {
  306.                 case 1: prntcmd = rightint; break;
  307.                 case 2: debug = rightint; break;
  308.                 }
  309.             goto return_nil;
  310.  
  311.